;; -*- Mode: Lisp; -*-

;;; Tiny Rule Engine, ATMS interface: Rules module
;; Last edited: 1/29/93, KDF

;; Copyright (c) 1992, Kenneth D. Forbus, Northwestern
;; University, and Johan de Kleer, the Xerox Corporation
;; All rights reserved.

;;; See the file legal.txt for a paragraph stating scope of permission
;;; and disclaimer of warranty.  The above copyright notice and that
;;; paragraph must be included in any separate copy of this file.

(defpackage #:bps/atms/arules
  (:use #:cl
        #:bps/atms/atms
        #:bps/atms/ainter
        #:bps/atms/adata
        #:bps/atms/unify
        #:bps/atms/funify)
  (:export
   #:rule-file
   #:rule
   #:*macros-to-expand*
   #:fully-expand-body
   #:insert-rule
   #:try-rules
   #:run-rules
   #:enqueue
   #:dequeue
   #:show-rules
   #:print-rules
   #:print-rule
   #:get-rule))

(in-package #:bps/atms/arules)

(defvar *rule-procedures* nil) ;; while defining rules
(defvar *in-nodes* nil)        ;; Part of rule triggering
(defvar *imp-nodes* nil)       ;; environment.

(defvar *file-counter* 0)
(defvar *file-prefix* "")

(defmacro Rule-File (prefix)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (setq *file-counter* 0)
     (setq *file-prefix* ,prefix)))

;;;; Defining rules
;;; <condition> =  :INTERN | :IN | :IMPLIED-BY
;;; If you want to mix trigger types, use nested calls to RULE.
;; Trigger syntax is
;; (<pattern1> . <options for pattern1>
;;     <pattern2> <options for pattern2> ...)
;;  and <options> can be empty, or
;;  :TEST <code> and/or :VAR <var>, where <code> must be
;;  non-nil for the match to succeed, and <var> will be
;;  bound to the whole pattern.
;; e.g., ((Queen ?x1 ?y1) :VAR ?f1
;;        (Queen ?x1 ?y2) :VAR ?f2 :TEST (not (= ?y1 ?y2)))

(defmacro rule (condition trigger-list &rest body)
  (do-rule condition (parse-triggers trigger-list) body))

(defun parse-triggers (trigger-list)
  (cond ((null trigger-list) nil)
        (t (multiple-value-bind (var test new-triggers)
            (parse-trigger-options (cdr trigger-list) nil nil)
            (cons (list (car trigger-list) var test)
                  (parse-triggers new-triggers))))))

(defun parse-trigger-options (triggers var test)
  (case (car triggers)
        (:VAR (parse-trigger-options
               (cddr triggers) (cadr triggers) test))
        (:TEST (parse-trigger-options
                (cddr triggers) var (cadr triggers)))
        (t (values var test triggers))))

;;;; Orchestrating the rule expansion

(defun do-rule (condition triggers body)
  (let ((*rule-procedures* nil)
        (*bound-vars* nil)
        (index-form nil))
    (setq index-form
          (build-rule
           condition (car triggers)
           (subst 'internal-rule 'rule
                  (make-nested-rule
                   condition (cdr triggers) body))))
    `(with-compilation-unit ()
       ,@ *rule-procedures*
       ,index-form)))

(defmacro internal-rule (condition triggers-in &rest body)
  (let ((triggers (parse-triggers triggers-in)))
    `(add-internal-rule
      ,condition ,(car triggers)
      ,(make-nested-rule condition (cdr triggers) body))))

(defun make-nested-rule (condition triggers body)
  (cond ((null triggers) body)
        (t `((add-internal-rule ,condition
               ,(car triggers)
               ,(make-nested-rule
                 condition (cdr triggers) body))))))

(defmacro add-internal-rule (condition trigger body)
  (build-rule condition trigger body))

;;;; Building rules

(defun build-rule (condition trigger body
                             &aux match-procedure
                             body-procedure)
  (let ((pattern (car trigger))
        (var (cadr trigger))
        (test (caddr trigger)))
   (setq match-procedure
         (generate-match-procedure
          pattern var test condition))
   (setq body-procedure
         (generate-body-procedure
          pattern condition var body))
   (push match-procedure *rule-procedures*)
   (push body-procedure *rule-procedures*)
   `(insert-rule
     (get-dbclass ,(get-trigger-dbclass pattern))
     ;return form to index rule
       ,(if *bound-vars* ;the match function for rule
            `(function (lambda (p)
               (,(cadr match-procedure) p ,@ *bound-vars*)))
          `(function ,(cadr match-procedure)))
     (function ;;the body function for rule
       ,(if (or *bound-vars*
                (not (eq condition :INTERN)))
            (let ((tv (nreverse
                        (pattern-free-variables trigger))))
              (unless (eq condition :INTERN)
                      (push 'TRIGGER-NODE tv))
              `(lambda ,tv
                 (,(cadr body-procedure) ,@ tv
                  ;(fn-name parameters)
                  ,@ (scratchout tv *bound-vars*))))
              (cadr body-procedure)))
     *in-nodes*
     *imp-nodes*)))

(defun get-trigger-dbclass (trigger)
  (cond ((null trigger) (error "Null trigger in ATRE rule"))
        ((variable? trigger)
         (if (member trigger *bound-vars*)  trigger
             (error "~%Trigger dbclass is unbound -- ~A."
                    trigger)))
        ((symbolp trigger)  (list 'QUOTE trigger))
        ((listp trigger) (get-trigger-dbclass (car trigger)))
        (t (error
  "ATRE rule trigger must be symbol or list: ~A" trigger))))

;;;; Generating the body procedure

(defmacro with-pushed-variable-bindings (new-bindings
                                          &rest body)
;; generate-body-procedure needs this
  `(let ((*bound-vars* (append ,new-bindings
                               (scratchout ,new-bindings
                                           *bound-vars*))))
     ,@ body))

(defun generate-body-procedure (pattern condition var body
                                    &aux newly-bound env fname)
  (setq newly-bound (pattern-free-variables pattern))
  (if var (push var newly-bound))
  (setq body (with-pushed-variable-bindings
               newly-bound (fully-expand-body body)))
  (setq env (append newly-bound
                    (scratchout newly-bound *bound-vars*)))
  (unless (eq condition :INTERN) (push 'trigger-node env))
  (setq fname (generate-rule-procedure-name pattern))
  `(defun ,fname ,env
     (declare (ignorable ,@env))
     ,@ (cond ((eq condition :INTERN) body) ;; Just do it
              (t ;; Must check and see if the node's belief state
                 ;; matches the rule's requirements
               `((cond ((,(case condition
                           (:IN 'tms-node-label)
                           (:IMPLIED-BY 'tms-node-label)
                           (t (error "~A bad condition -- GBF"
                                     condition)))
                         TRIGGER-NODE) ,@ body)
                   (t (push (list ',fname ,@ env)
                            (tms-node-rules TRIGGER-NODE)))))))))

(defun generate-match-procedure (pattern var test condition)
  (multiple-value-bind (tests binding-specs)
      (generate-match-body
       pattern (pattern-free-variables pattern) test)
    `(defun ,(generate-rule-procedure-name pattern)
         (P ,@ *bound-vars*)
       (declare (ignorable ,@*bound-vars*))
       ;;first arg, P, is the pattern
       (if (and ,@ tests)
           (values
            T ,(if (and (null var) (null binding-specs)) nil
                   `(list ,@ (if var '(P))
                             ,@ (reverse binding-specs)))
            ,condition)))))

(defun scratchout (l1 l2)
  ;non-destructive and order-preserving
  (dolist (el1 l1 l2)
    (setq l2 (remove el1 l2))))

(defun generate-rule-procedure-name (pattern)
  (intern (format nil "~A-~A-~A"
                  *file-prefix* pattern (incf *file-counter*))))

;;;; Recursive macroexpansion

(defvar *macros-to-expand*
  '(rule internal-rule add-internal-rule with-pushed-variable-bindings
    rlet rassert! rnogood! with-focus with-ATRE))

(defun fully-expand-body (body)
  (cond ((null body) nil)
        ((not (listp body)) body)
        ((symbolp (car body))
         (cond ((member (car body) *macros-to-expand*)
                (fully-expand-body (macroexpand body)))
               (t (cons (car body)
                        (fully-expand-body (cdr body))))))
        (t (cons (fully-expand-body (car body))
                 (fully-expand-body (cdr body))))))


;;;; Running rules

(defun insert-rule (dbclass matcher body in-nodes imp-nodes
                            &aux rule atre)
  (setq atre (dbclass-atre dbclass))
  (setq rule (make-rule
              :MATCHER matcher
              :ATRE atre
              :BODY body
              :DBCLASS dbclass
              :COUNTER (incf (atre-rule-counter atre))
              :IN-NODES in-nodes
              :IMP-NODES imp-nodes))
  ;; Index it
  (push rule (atre-rules atre))
  (push rule (dbclass-rules dbclass))
  (dolist (candidate (dbclass-facts dbclass))
          (try-rule-on rule candidate)))

(defun try-rules (datum)
  (dolist (rule (dbclass-rules (datum-dbclass datum)))
    (try-rule-on rule datum)))

(defun try-rule-on (rule datum &aux a)
  (setq a (datum-atre datum))
  (multiple-value-bind (okay? bindings condition)
      (funcall (rule-matcher rule) (datum-lisp-form datum))
    (when okay?
      (when (or (eq condition :IN)
                (eq condition :IMPLIED-BY))
        (push (datum-tms-node datum) bindings))
      (enqueue (list (rule-body rule) bindings
                     (case condition
                       (:IN (cons
                             (cons (datum-tms-node datum)
                                   (rule-in-nodes rule))
                             (rule-imp-nodes rule)))
                       (:IMPLIED-BY
                        (cons (rule-in-nodes rule)
                              (cons (datum-tms-node datum)
                                    (rule-imp-nodes rule))))
                       (:INTERN
                        (cons (rule-in-nodes rule)
                              (rule-imp-nodes rule)))))
               a))))

(defun run-rules (&optional (*atre* *atre*))
  (setf (atre-queue *atre*)
        (nconc (atre-queue *atre*)
               (atre-in-rules *atre*)))
  (setf (atre-in-rules *atre*) nil)
  (do ((form (dequeue *atre*) (dequeue *atre*))
       (counter 0 (1+ counter)))
      ((null form)
       (debugging-atre "~%    ~A rules run."  counter)
       (values counter
               (incf (atre-rules-run *atre*) counter)))
      (execute-rule form *atre*)))

;;;; Executing rules, checking for appropriate conditions

(defun execute-rule (queued-rule atre)
  ;; Now is (<procedure> <arguments> <node list>)
  ;; Check the node list before executing, to make sure
  ;; all the belief conditions are satisifed.
  (let ((*in-nodes* (car (third queued-rule)))
        (*imp-nodes* (cdr (third queued-rule))))
    (unless (in-triggers-ready? *in-nodes* atre)
      ;; Re-queue under ATRE for checking.
      ;; ****** Introduce temporary nodes?  Cache rules
      ;; ****** on justifications?
      (push queued-rule (atre-in-rules atre))
      (return-from EXECUTE-RULE nil))
    (unless (implied-by-triggers-ready? *imp-nodes* atre)
      (push queued-rule (atre-imp-rules atre))
      (return-from EXECUTE-RULE nil))
    ;; Let's do it
    (apply (car queued-rule) (cadr queued-rule))))

(defun in-triggers-ready?
  (nodes atre &optional (env (atms-empty-env
                              (atre-atms atre))))
  (cond ((env-nogood? env) nil) ;; Combination was nogood
        ((null nodes) t) ;; Nothing else to combine
        (t (dolist (new (tms-node-label (car nodes)))
             (let ((u (union-env new env)))
               (if (in-triggers-ready? (cdr nodes) atre u)
                   (return-from IN-TRIGGERS-READY? t)))))))

(defun implied-by-triggers-ready? (nodes atre)
  (or (null nodes) ;; No triggers, no problem
      (and (focus-okay? atre)
           (every #'(lambda (n)
                      (in-node? n (atre-focus atre)))
                  nodes))))

(defun rules-waiting? (atre) (atre-queue atre))

(defun enqueue (new a) (push new (atre-queue a)))

(defun dequeue (atre)
  (if (atre-queue atre) (pop (atre-queue atre))))

;;;; Display routines

(defun show-rules (&optional (atre *atre*)
                             (stream *standard-output*)
                        &aux counter dist inc imp in contra
                        queued)
  (setq counter 0)
  (dolist (dbclass (atre-dbclasses atre))
    (setq inc (length (dbclass-rules dbclass)))
    (when (> inc 0)
      (push (cons (dbclass-name dbclass) inc) dist)
      (incf counter inc)))
  (setq in (length (atre-in-rules atre))
        imp (length (atre-imp-rules atre))
        contra 0 queued (length (atre-queue atre)))
  (setq counter (+ in imp counter))
  (format stream "~% ~A has ~D rules in all."
          (atre-title atre) counter)
  (format stream "~%  ~A queued."
          (if (> queued 0) queued "None"))
  (if (> (+ in imp contra) 0)
      (format stream "  Pending: ~A in, ~A implied-by."
              (if (> in 0) in "No") (if (> imp 0) imp "No"))
      (format stream "  None pending."))
  (when dist
    (format stream "~% Cached under dbclasses:")
    (dolist (entry dist)
      (format stream "~%    ~A: ~D"
              (car entry) (cdr entry))))
  atre)

(defun print-rules (&optional (atre *atre*)
                              (stream *standard-output*)
                              &aux counter)
  (setq counter 0)
  (format t "~%The rules in ~A are:" (atre-title atre))
  (dolist (rule (atre-rules atre))
          (incf counter)
          (print-rule rule stream))
    counter)

(defun print-rule
  (rule &optional (stream *standard-output*))
  (format stream "~% ~A: ~A, ~A"
          rule (rule-matcher rule) (rule-body rule)))

(defun test-rule-expansion ()
 (pprint (macroexpand
          '(rule :IN  ((implies ?p ?q) :VAR ?f1 ?p)
                 (rassert! ?q (:CE ?f1 ?p))))))

(defun get-rule (num &optional (atre *atre*))
  (dolist (rule (atre-rules atre))
    (when (= (rule-counter rule) num)
          (return-from GET-RULE rule))))
